home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / pistol.zip / PBASE < prev    next >
Text File  |  1987-08-20  |  17KB  |  814 lines
  1. % *********************************************************
  2. % *                              *
  3. % * PISTOL-Portably Implemented Stack Oriented Language      *
  4. % *            Version 1.3              *
  5. % * (C) 1982 by    Ernest E. Bergmann              *
  6. % *        Physics, Building #16              *
  7. % *        Lehigh Univerisity              *
  8. % *        Bethlehem, Pa. 18015              *
  9. % *                              *
  10. % * Permission is hereby granted for all reproduction and *
  11. % * distribution of this material provided this notice is *
  12. % * is included.                      *
  13. % *                              *
  14. % *********************************************************
  15.  
  16. % BASIC DEFINITIONS IN PISTOL FOR PISTOL- "PBASE"
  17. % FEBRUARY 6, 1982, RECURSE DEF. FIXED
  18.  
  19. % DECIMAL mode initially
  20.  
  21. -6 W * USER + W@ W@ % used for 'LAST-PRIMITIVE
  22. 'W*  W 1 - IF : W * ;
  23.     ELSE $: ;$
  24.     THEN
  25. 'USER+ USER IF $: USER + ;$
  26.         ELSE $: ;$
  27.         THEN
  28. 'TRANS $: W* USER+ ;$ % TRANSLATES LOGICAL ADDRESSES TO ACTUAL
  29.         % RAM ADDR.
  30.         % TRANS MUST USE "$:" FOR THE 'DIS PACKAGE
  31. 'TRANS@ : TRANS W@ ;
  32. 'ARGPATCH : -6 TRANS@  W@ W + W! ; % for 'CONSTANT 'VARIABLE,
  33.                    %  and 'ARRAY
  34. 'CONSTANT : : 0 ; ARGPATCH ;
  35.  
  36. 'LAST-PRIMITIVE CONSTANT
  37.  
  38. -1    'TRUE    CONSTANT
  39. 0    'FALSE    CONSTANT
  40.  
  41. -57 TRANS@    'MAXLINNO    CONSTANT
  42. -56 TRANS@    'CHKLMT        CONSTANT
  43. -55 TRANS@    'RAMMIN        CONSTANT
  44. -54 TRANS@    'STRINGSMIN    CONSTANT
  45. % -53 TRANS NOT CURRENTLY BEING USED
  46. -52 TRANS    'ABORT-PATCH    CONSTANT
  47. -51 TRANS    'CONVERT-PATCH    CONSTANT
  48. -50 TRANS    'PROMPT-PATCH    CONSTANT
  49. -49 TRANS@    'STRINGSMAX    CONSTANT
  50. -48 TRANS@    'VBASE        CONSTANT
  51. -47 TRANS@    'VSIZE        CONSTANT
  52. VBASE VSIZE W* + 'VMAX    CONSTANT
  53. -46 TRANS@    'CSIZE        CONSTANT
  54. -45 TRANS@    'LSIZE        CONSTANT
  55. -44 TRANS@    'RSIZE        CONSTANT
  56. -43 TRANS@    'SSIZE        CONSTANT
  57. -42 TRANS@    'LINEBUF    CONSTANT
  58. LINEBUF 200 + 'EDITBUF        CONSTANT
  59. -41 TRANS@    'COMPBUF    CONSTANT
  60. -40 TRANS@    'RAMMAX        CONSTANT
  61. -39 TRANS@    'MAXORD        CONSTANT
  62. -38 TRANS@    'MAXINT        CONSTANT
  63. % -37 TRANS NOT CURRENTLY BEING USED
  64. -36 TRANS@    'VERSION    CONSTANT
  65.  
  66. 'ON : TRUE SWAP W! ;
  67. 'OFF : FALSE SWAP W! ;
  68. 'INFILE : -11 TRANS@ ;
  69.  
  70. 'BYE : -35 TRANS ON ;
  71. -34 TRANS '(PISTOL<) CONSTANT
  72. -32 TRANS '.V CONSTANT
  73. -29 TRANS 'LOADFILE-STATUS CONSTANT
  74. -28 TRANS '#GET-ADDR CONSTANT % FOR PATCHING #GETLINE
  75. -27 TRANS 'TAB-SIZE CONSTANT
  76. -26 TRANS 'TRACE-ADDR CONSTANT
  77. -25 TRANS 'ENDCASE-PATCH CONSTANT
  78. -24 TRANS 'COLUMN CONSTANT
  79. -23 TRANS 'TERMINAL-WIDTH CONSTANT
  80. -22 TRANS '#LINES CONSTANT
  81. -21 TRANS 'TERMINAL-PAGE CONSTANT
  82. -20  TRANS 'COMPILE-END-PATCH CONSTANT
  83. -19 TRANS 'TRACE-LEVEL CONSTANT % USED AS BOOLEAN AND LEVEL
  84.                 % INDICATOR
  85. -17 TRANS 'RAISE CONSTANT
  86. -15 TRANS 'NEXTCH^ CONSTANT
  87. -14 TRANS 'CONSOLE CONSTANT
  88. -13 TRANS 'ECHO CONSTANT
  89. -12 TRANS 'LIST CONSTANT
  90. -6 TRANS 'CURRENT CONSTANT
  91. -5 TRANS 'OLD-EOSTRINGS CONSTANT % END OF PERMANENT STRINGS
  92.                  % VARIABLE
  93. -4 TRANS 'CURRENT-EOSTRINGS CONSTANT
  94. -3 TRANS '.D CONSTANT
  95. -2 TRANS '.C CONSTANT
  96. -1 TRANS 'RADIX CONSTANT
  97. STRINGSMIN 'RADIX-INDICATOR CONSTANT
  98. STRINGSMIN 1 + 'SYNTAXBASE CONSTANT
  99.  
  100. 'NOP : ;
  101. 'DUP : 0 S@ ;
  102. '1+ : 1 + ;
  103. '1- : 1 - ;
  104. 'W+ : W + ;
  105. 'W- : W - ;
  106. 'W<- : SWAP W! ;
  107. '1+W! : DUP W@ 1+ W<- ;
  108. 'W+W! : DUP W@ W+ W<- ;
  109. 'CR : 13 TYO ;
  110. 'SPACE : 32 TYO ;
  111. 'SPACES : 0 DO SPACE LOOP ;
  112. 'DDUP : 1 S@ 1 S@ ;
  113. 'OVER : 1 S@ ;
  114. '2OVER : 2 S@ ;
  115. '3OVER : 3 S@ ; % USED BY DIS PACKAGE(DON'T CHANGE!)
  116. 'UNDER : SWAP DROP ;
  117. 'TYPE : 0 DO DUP C@ TYO 1+ LOOP DROP ;
  118. 'LT : SWAP GT ;
  119. 'LINE-SPACE? : COLUMN W@ + TERMINAL-WIDTH W@ LT
  120.     IF ELSE CR THEN ;
  121.  
  122. 'MSG : DUP C@ LINE-SPACE?
  123.      DUP 1+ SWAP C@ TYPE ;
  124.  
  125. 'IFCR : COLUMN W@ 0 GT IF CR THEN ;
  126. 'ERR : IFCR ABORT ;
  127.  
  128. 'MERR : CONSOLE ON MSG ERR ;
  129.  
  130.  
  131. 'INDENT : DUP TERMINAL-WIDTH W@ LT IF
  132.     COLUMN W@ - SPACES
  133.     ELSE IFCR DROP
  134.     THEN ;
  135.  
  136. 'TAB : 9 TYO ;
  137.  
  138. 'TABS : 0 DO TAB LOOP ;
  139.  
  140. 'ALLOT : W* .D W@ + .D W! ; % advances dictionary pointer
  141.             % by the amount given by top of stack
  142. 'W, :        % PLACES TOS AT END OF DICTIONARY
  143.     .D W@ W! 1 ALLOT
  144.     ;
  145. 'VARIABLE : : 3 ;    % create definition
  146.     .D W@ ARGPATCH    % point it at end of dictionary
  147.     W,        % initialize variable
  148.     ;        % finish with allocating space
  149. 'ARRAY : : 3 ;        % create definition
  150.     .D W@ ARGPATCH    % point it at end of dictionary
  151.     ALLOT ;        % allocate requested space and ;
  152.  
  153.  
  154. % VOCABULARY RELATED DEFINITIONS:
  155. '> : .V W@ DUP VBASE GT    % "POPS" VOCABULARY STACK
  156.     IF W- .V W!
  157.     ELSE "*** VSTACK UNDERFLOW***" MERR
  158.     THEN
  159.     ;
  160.  
  161. '<V :    % TRANSFERS TOS TO TOP OF VSTACK
  162.     .V W@ DUP VMAX LT
  163.     IF W+ DUP .V W! W!
  164.     ELSE "*** VSTACK OVERFLOW***" MERR
  165.     THEN
  166.     ;
  167.  
  168. 'PISTOL< : (PISTOL<) <V ;
  169.  
  170.  
  171. (PISTOL<)    'BRANCH-LIST    VARIABLE
  172.  
  173. 'BRANCH :    % CREATES AN ARRAY OF TWO ELEMENTS
  174.         % AND A PROCEDURE THAT PUSHES A ^
  175.         % TO THE FIRST ELEMENT OF THE ARRAY
  176.         % THIS FIRST ELEMENT CONTAINS A ^
  177.         % TO THE CURRENT HEAD OF THE VOCABULARY
  178.         % BRANCH AND THE SECOND ELEMENT IS A
  179.         % BACKWARD LINK TO THE PREVIOUS HEAD.
  180.         % BRANCH-LIST CONTAINS THE ^ TO THE
  181.         % THREADED LIST OF BRANCHES THAT HAVE
  182.         % BEEN DEFINED; THE BACKWARD LINK FOR
  183.         % (PISTOL<) IS "NIL"
  184.     : 3 <V ; .D W@ ARGPATCH
  185.     0 .D W@ W!
  186.     BRANCH-LIST W@ .D W@ W+
  187.     W!
  188.     .D W@ BRANCH-LIST
  189.     W!
  190.     2 ALLOT
  191.     ;
  192.  
  193. 'SYSTEM< BRANCH    % CAN BE USED FOR RARELY USED, OBSCURE,
  194.         % OR DANGEROUS WORDS
  195.  
  196.  
  197. 'BLIST :    % LISTS THE NAMES OF ALL DEFINED BRANCHES
  198.     BRANCH-LIST W@
  199.     BEGIN
  200.         DUP W+ W@ DUP    % GET LINK
  201.         IF
  202.             SWAP 6 W* -
  203.             W@ MSG CR
  204.     REPEAT
  205.     DROP DROP
  206.     IFCR
  207.     'PISTOL< MSG
  208.     ;
  209.  
  210. % DO LOOP INDICES:
  211. 'I : 0 L@ ;
  212. 'J : 3 L@ ;
  213. 'K : 6 L@ ;
  214.  
  215. 'I' : 2 L@ 1 L@ + 1- 0 L@ - ;
  216. 'J' : 5 L@ 4 L@ + 1- 3 L@ - ;
  217. 'K' : 8 L@ 7 L@ + 1- 6 L@ - ;
  218.  
  219. % SOME LOGICAL OPERATORS:
  220.  
  221. 'LOR : IF DROP TRUE THEN ;        % LOGICAL OR
  222.  
  223. 'LAND : IF ELSE DROP FALSE THEN ;    % LOGICAL AND
  224.  
  225. 'NOT : IF FALSE ELSE TRUE THEN ;
  226.  
  227. % NUMBER OUTPUT ROUTINE:
  228.  
  229. % ASCII <-- DIGIT
  230. 'ASCII : DUP 9 GT IF 55
  231.         ELSE 48
  232.     THEN + ;
  233.  
  234.  
  235. 'MINUS : 0 SWAP - ;
  236.  
  237. '<U#> : -1 SWAP BEGIN RADIX W@ /MOD SWAP DUP NOT END DROP ;
  238.  
  239. '#TYPE : BEGIN DUP -1 GT IF ASCII TYO REPEAT DROP ;
  240.  
  241. '= : DUP 0 LT IF  45 TYO MINUS THEN
  242.     <U#> #TYPE ;
  243. '? : W@ = ;
  244.  
  245. % BELOW ARE WORDS THAT CONTROL DISPLAY OF CODE PRODUCED
  246. % BY THE COMPILER; CAN BE USEFUL FOR DEBUGGING AND EDUCATION
  247.  
  248. 'CODESHOW : IFCR "COMPILE BUFFER CONTAINS:" MSG CR
  249.     COMPBUF    BEGIN DUP ? TAB W+
  250.             .C W@ OVER GT NOT
  251.         END
  252.     DROP IFCR
  253.     ;
  254. 'SHOWCODE : 'CODESHOW FIND COMPILE-END-PATCH W! ;
  255. % SHOWCODE SHOULD NOT BE CHANGED WITHOUT CHECKING 'DIS PACKAGE
  256.  
  257. 'NOSHOWCODE : COMPILE-END-PATCH OFF ;
  258.  
  259. 'PROMPT :    % DUPLICATES PRIMITIVE PROMPT
  260.     IFCR    % FUNCTION
  261.     SP IF SP = THEN    % EXCEPT STACK SIZE SHOWN
  262.     RADIX-INDICATOR C@ TYO
  263.     SYNTAXBASE MSG
  264.     "> " MSG
  265.     ;
  266. 'PROMPT FIND PROMPT-PATCH W!    % PATCHING IT
  267.  
  268. 0 'FENCE VARIABLE
  269.  
  270. 'ADDRESS : DUP FIND DUP IF UNDER
  271.             ELSE IFCR
  272.                 39 TYO DROP MSG
  273.                 " NOT FOUND" MERR
  274.             THEN ;
  275.  
  276.  
  277. 'FORGET : ADDRESS DUP FENCE W@
  278.     GT IF % ADDRESS OK, SO TRUNCATE EVERYTHING:
  279.     DUP W- W- W@ DUP OLD-EOSTRINGS W!
  280.     CURRENT-EOSTRINGS W!
  281.     W- W- W- DUP W@ CURRENT W@ W! W- .D W!
  282.     ELSE % ADDRESS BELOW FENCE
  283.         "BELOW FENCE" MERR THEN ;
  284.  
  285. % PROTECT 'FORGET WITH THE FENCE:
  286.  
  287. 'FORGET FIND FENCE W!
  288.  
  289.  
  290. '/ : /MOD DROP ;
  291. 'MOD : /MOD UNDER ;
  292.  
  293.  
  294. % CHANGING NUMBER BASES:
  295. 'HEX : 72 RADIX-INDICATOR C! 16 RADIX W! ;
  296. 'DECIMAL : 88 RADIX-INDICATOR C! 10 RADIX W! ;
  297. 'OCTAL : 81 RADIX-INDICATOR C! 8 RADIX W! ;
  298. 'BINARY : 66 RADIX-INDICATOR C! 2 RADIX W! ;
  299.  
  300. 'LTZ    : 0 LT    ;
  301. 'GTZ    : 0 GT    ;
  302. 'EQZ    : NOT    ;
  303. 'ABS    : DUP LTZ IF MINUS THEN ;
  304. 'EQ    : - NOT ;
  305. 'MIN : DDUP GT IF SWAP THEN DROP ;
  306.  
  307. 'MAX : DDUP LT IF SWAP THEN DROP ;
  308.  
  309. % RANGE TEST:
  310. '.. : 2OVER LT SWAP 2OVER GT LOR NOT UNDER ;
  311.  
  312.  
  313. %
  314. 'STACK : IFCR 40 TYO SP = 41 TYO % (STACKSIZE)
  315.     SP SP 12 MIN 1- 0 DO 2 SPACES DUP S@ = 1- LOOP
  316.     DROP ;
  317. %
  318. 'RSTACK : IFCR 'R( MSG RP 1- = 41 TYO % RSTACK SIZE
  319.     RP 1- DUP 12 MIN 0 DO 2 SPACES DUP R@ = 1-
  320.     LOOP DROP ;
  321.  
  322. % RECURSE ALOWS ROUTINE OR COMPBUF TO CALL ITSELF
  323. 'RECURSE :    1 R@ W-    % FIND ADDRESS OF WORD RECURSE IS IN
  324.         0 R@ W- % FIND WHERE RECURSE IS USED
  325.         W!    % "PATCH"
  326.         R> W- <R % BACK UP INSTRUCTION POINTER
  327.     ;
  328. %
  329. 'TELL : W- W- W@ DUP STRINGSMIN STRINGSMAX .. IF MSG
  330.         ELSE "NOT VALID WORD ADDRESS" MERR THEN
  331.     ;
  332. 'NEXT-LINK : W- W- W- W@ ;
  333. %
  334. % THIS BOMBS WHEN > NUMINSTRUCTIONS
  335. 'PNAME : DUP IF
  336.         LAST-PRIMITIVE
  337.         BEGIN    DUP
  338.             IF    DDUP W@ EQ
  339.                 IF    TELL    TRUE
  340.                 ELSE    NEXT-LINK FALSE
  341.                 THEN
  342.             ELSE    '(NO_NAME) MSG    NOT
  343.             THEN
  344.         END
  345.         DROP
  346.         ELSE '; MSG DROP
  347.         THEN
  348.     ;
  349. %
  350. 'NAME : DUP KERNEL? IF
  351.     PNAME
  352.     ELSE TELL
  353.     THEN ;
  354. % LLIST ADDRESS AND NAME:
  355. 'LNAME : DUP = 3 SPACES NAME CR ;
  356. %
  357. % LIST LAST TEN WORDS:
  358. 'NEXT10 : IFCR 10 0 DO DUP NOT IF ERR THEN
  359.         DUP LNAME NEXT-LINK LOOP ;
  360. 'TOP10 : % OF VOCBULARY TO WHICH DEFINITIONS ARE
  361.      % CURRENTLY BEING ADDED
  362.  
  363.     CURRENT W@ W@ NEXT10 ;
  364.  
  365. 'VLIST : % TOP TEN WORDS IN FIRST VOCABULARY TO BE SEARCHED
  366.     .V W@ W@ W@ NEXT10 ;
  367.  
  368. % CASE INDICES:
  369. 'ICASE : 0 CASE@ ;
  370. 'JCASE : 2 CASE@ ;
  371. 'CASE-ADDR : 1 CASE@ ;
  372. '(ENDCASE) : IFCR "ENDCASE ENCOUNTERED WITH VALUE = " MSG
  373.     ICASE = " AT " MSG CASE-ADDR = ERR ;
  374. '(ENDCASE) ADDRESS ENDCASE-PATCH W! % PATCH ENDCASE
  375. '(ENDCASE) ADDRESS FENCE W! % RAISE FENCE
  376.  
  377. % SPECIAL STRING ROUTINES:
  378.  
  379. % PACK puts TOS onto the end of the strings area.
  380. 'PACK : CURRENT-EOSTRINGS W@ C!
  381.     CURRENT-EOSTRINGS 1+W! ;
  382.  
  383. '=PACK : CURRENT-EOSTRINGS W@ <R
  384.     CURRENT-EOSTRINGS 1+W!
  385.     DUP LTZ IF 45 PACK MINUS THEN
  386.     <U#> BEGIN DUP -1 GT IF ASCII PACK REPEAT
  387.     DROP R> CURRENT-EOSTRINGS W@ OVER -
  388.     1- OVER C! ;
  389. % =PACK IS USED TO CREATE A NUMBER STRING. IT
  390. % TAKES THE TOP SIGNED NUMBER ON STACK AND CONVERTS IT
  391. % TO A STRING THAT COULD BE OUTPUT BY MSG
  392.  
  393. % THE NEXT TWO ROUTINES TAKE AS INPUT
  394. % A BUNCH OF STRING POINTERS
  395. % AND THEIR NUMBER FROM THE TOP OF STACK.
  396. 'MSGS-COUNT : SP 1- OVER LT IF "NOT ENOUGH STRINGS"
  397.     MERR THEN
  398.     0 SWAP 1+ 1 DO I S@ C@ + LOOP ;
  399.  
  400. 'MSGS : DUP <R DUP <R MSGS-COUNT LINE-SPACE?
  401.     R> 0 DO I' S@ MSG LOOP R> 0 DO DROP LOOP
  402.     ;
  403. % In the above, MSGS will output a bunch of strings
  404. % that were left on stack IN THE ORDER they were placed
  405. % on stack, trying to place them all on the same line;
  406. % failing that, it will try and not split the individual
  407. % strings across lines.  It will be used to improve the
  408.  
  409. % DISASSEMBLER PACKAGE
  410.  
  411. 'DIS-TRIAL :    % CONTAINS ALL REL-OPS IN THE KERNEL
  412.     DO +LOOP
  413.     DO LOOP
  414.     IF ELSE
  415.     THEN
  416.     OFCASE C: ;C ENDCASE
  417.     : ;
  418.     $: ;$
  419. ;
  420. 'NEXT-TRIAL :    % CONVENIENCE TO STEP THROUGH DIS-TRIAL
  421.     W+ W+ DUP W@
  422.     ;
  423. 'OP-TYPE :    % USED TO DEFINE WORDS FOR TESTING KERNEL OPS
  424.     DUP    :
  425.         3 EQ IF "" TRUE ELSE FALSE THEN
  426.         ;
  427.         CURRENT W@ W@ 6 W* + W!    % GET THE NAME OF
  428.                     % DEFINITION
  429.         ARGPATCH    % RECORD THE VALUE OF OPCODE
  430.     ;
  431.  
  432. '3OVER FIND    % IT STARTS WITH A LITERAL CONSTANT
  433. W@ 'LITERAL    CONSTANT
  434.  
  435. 'SHOWCODE FIND    % IT STARTS WITH A STRING LITERAL
  436. W@ 'STRING-LIT    CONSTANT
  437.  
  438. 'TRANS FIND    % IT IS A "$:" WORD
  439. W- W@ '[$:]    OP-TYPE
  440.  
  441. 'DIS-TRIAL FIND
  442. DUP W- W@ '[:]        OP-TYPE
  443. NEXT-TRIAL '(+LOOP)    OP-TYPE
  444. NEXT-TRIAL '(DO)    OP-TYPE
  445. NEXT-TRIAL '(LOOP)    OP-TYPE
  446. NEXT-TRIAL '(IF)    OP-TYPE
  447. NEXT-TRIAL '(ELSE)    OP-TYPE
  448. NEXT-TRIAL '(OFCASE)    OP-TYPE
  449. NEXT-TRIAL '(C:)    OP-TYPE
  450. W+ W+
  451. NEXT-TRIAL '(:)        OP-TYPE
  452. NEXT-TRIAL '(;)        OP-TYPE
  453. W-
  454. NEXT-TRIAL '($:)    OP-TYPE
  455. DROP
  456.  
  457. 'REL-OP    :
  458.     SWAP W+ W@ =PACK
  459.     " [" SWAP ']
  460.     4 MSGS W W+
  461.     ;
  462. 'DIS-TOKEN :
  463.     DUP W@ OFCASE
  464.     (;)    C: MSG DROP W ;C
  465.     LITERAL EQ    C: W+ W@ =PACK MSG W W+ ;C
  466.     STRING-LIT EQ    C: W+ W@ '" SWAP OVER
  467.                 3 MSGS W W+    ;C
  468.     (DO)    C: REL-OP ;C
  469.     (LOOP)    C: REL-OP ;C
  470.     (+LOOP)    C: REL-OP ;C
  471.     (IF)    C: REL-OP ;C
  472.     (ELSE)    C: REL-OP ;C
  473.     (OFCASE) C: REL-OP ;C
  474.     (C:)    C: REL-OP ;C
  475.     (:)    C: REL-OP ;C
  476.     ($:)    C: REL-OP ;C
  477.     TRUE    C: NAME DROP W ;C
  478.     ENDCASE
  479.     ;
  480. 'WORD-ID : IFCR 39 TYO DUP MSG SPACE ADDRESS ;
  481.  
  482. 'DIS : WORD-ID
  483.     DUP W- DUP W@ DUP
  484.     [:] IF MSG DROP
  485.     ELSE [$:] IF MSG
  486.         ELSE "NON-STANDARD IMMEDIATE WORD"
  487.             MERR
  488.         THEN
  489.     THEN
  490.     W- W- W- W@    % GET ^ TO END OF CODE
  491.     SWAP    DO
  492.         TAB I DIS-TOKEN
  493.         +LOOP
  494.     TAB '; MSG
  495. ;
  496.  
  497. % TRACE PACKAGE:
  498.  
  499. % ROUTINE THAT DISPLAYS THE STATE OF THE MACHINE
  500. % AT EACH TRACE AND TERMINATES TRACE AT END OF
  501. % ROUTINE BEING TRACED.
  502. '(TRACE) : STACK 48 INDENT 0 R@ W@ DUP
  503.     (;)    IF MSG DROP 0 TRACE-LEVEL W!
  504.         ELSE NAME 2 SPACES
  505.         THEN
  506.     ;
  507. % PERFORM PATCH:
  508. '(TRACE) ADDRESS TRACE-ADDR W!
  509.  
  510. 'TRACE : WORD-ID "BEING TRACED:" MSG
  511.         RP 3 + TRACE-LEVEL W!
  512.         EXEC IFCR "TRACE COMPLETED" MSG
  513.         CR
  514.     ;
  515.  
  516.  
  517. % EDIT PACKAGE:
  518.  
  519.  
  520. -31 TRANS    'OUTFILE-STATUS        CONSTANT
  521. -30 TRANS    'INPUTFILE-STATUS    CONSTANT
  522. STRINGSMAX 200 -
  523.     'SAFE-END        CONSTANT
  524. 1    'OLDLINE#    VARIABLE
  525. EDITBUF    'OLDLINE^    VARIABLE
  526. EDITBUF        'EOT    VARIABLE
  527.  
  528. 'NEWF : 1 OLDLINE# W!
  529.     EDITBUF OLDLINE^ W!
  530.     0 EDITBUF C!
  531.     EDITBUF EOT W!
  532.     ;
  533.  
  534. NEWF    % INITIALIZE EDITBUFFER
  535.  
  536. 'NEXTLINE : DUP C@ DUP IF + 1+
  537.         ELSE "***NO SUCH LINE***" MERR
  538.         THEN ;
  539.  
  540. 'LISTALL : 1 EDITBUF
  541.     BEGIN DUP C@
  542.     IF OVER = ": " MSG DUP MSG NEXTLINE
  543.     SWAP 1+ SWAP REPEAT DROP DROP ;
  544.  
  545. 'ILLEGLIN : "***ILLEGAL LINE #***" MERR ;
  546.  
  547.  
  548. 'LFIND : DUP OLDLINE# LT IF DUP 1 LT
  549.         IF ILLEGLIN THEN
  550.         DUP MAXLINNO GT IF ILLEGLIN THEN
  551.         EDITBUF OVER 1 DO
  552.             NEXTLINE LOOP
  553.         ELSE DUP OLDLINE#    % CALCULATE # OF
  554.             - OLDLINE^ W@    % LINES NEEDED TO
  555.             SWAP 0 DO
  556.             NEXTLINE LOOP    % ADVANCE
  557.         THEN
  558.         SWAP OLDLINE# W!
  559.         DUP OLDLINE^ W!
  560.     ;
  561.  
  562. 'LDIR : % CHARACTER BLOCK MOVE, INCREASING
  563.     % ON ENTRY: SOURCE, DESTINATION, #
  564.     % ON EXIT: SOURCE+#, DESTINATION+#
  565.  
  566.     0 DO OVER C@ OVER C!
  567.         1+ SWAP 1+ SWAP
  568.     LOOP
  569.     ;
  570.  
  571. 'LDDR :    % CHARACTER BLOCK MOVE, DECREASING
  572.     % ON ENTRY: SOURCE, DESTINATION, #
  573.     % ON EXIT: SOURCE-#, DESTINATION-#
  574.  
  575.     0 DO
  576.     OVER C@ OVER C!
  577.     1- SWAP 1- SWAP
  578.     LOOP
  579.     ;
  580.  
  581. '#GETLINE :    % TAKES THE LINE NUMBERED BY THE
  582.         % TOP OF THE STACK AND TRANSFERS
  583.         % IT INTO LINEBUF
  584.         LFIND
  585.         LINEBUF 1+ NEXTCH^ W!    % SYSTEM ^S
  586.         LINEBUF
  587.         OVER C@ 1+
  588.         LDIR
  589.         DROP DROP
  590.         ECHO W@ IF LINEBUF MSG THEN    % ECHO IF
  591.                         % APPROPRIATE
  592.     ;
  593.  
  594. '#GETLINE FIND #GET-ADDR W!    % DO THE PATCH
  595.  
  596.  
  597. 'MTUP :    % ON ENTRY: ^ TO BAS OF BLOCK BOUNDED BY EOT
  598.     % ON EXIT: ^ TO BASE OF MOVED BLOCK AT STRINGSMAX
  599.  
  600.     EOT W@ 1+ SWAP -    % # BYTES
  601.     EOT W@ SWAP    % SOURCE
  602.     STRINGSMAX SWAP    % DESTINATION
  603.     LDDR
  604.     UNDER 1+
  605.     ;
  606.  
  607. 'OVERWRITE :    % TAKES THE ^BOTTOM OF TEXT TO BE MOVED DOWN
  608.         %    ^TEXT TO BE OVERWRITTEN
  609.         % AND    ^LAST CHAR OF TEXT TO BE MOVED DOWN
  610.  
  611.         % ON EXIT LEAVES NO ARGS BUT HAS ADJUSTED EOT
  612.  
  613.     1+ 2OVER -
  614.     LDIR
  615.     1-
  616.     EOT W!
  617.     DROP
  618.     ;
  619.  
  620.  
  621. 'MTDN :    % ON ENTRY: ^ TO BASE OF BLOCK AT STRINGSMAX
  622.     %    AND ^ TO BASE OF DESTINATION
  623.  
  624.     STRINGSMAX
  625.     OVERWRITE
  626.     ;
  627.  
  628.  
  629.  
  630. 'LENTER : % TAKES ADDRESS ON TOP OF STACK AND MOVES INPUT
  631.       % LINE THERE; LEAVES A POINTER TO NEXT AVAILABLE
  632.       % LOCATION.
  633.     LINEBUF NEXTLINE LINEBUF
  634.     DO
  635.         I C@ OVER C! 1+
  636.     LOOP
  637.     ;
  638.  
  639. '1POSARG? :    % TESTS STACK TO SEE IF THERE IS EXACTLY
  640.         % ONE ARGUMENT; IT MUST BE POSITIVE.
  641.  
  642.         % ON EXIT IT LEAVES THAT ARGUEMENT.
  643.  
  644.     SP 1 EQ OVER -1 GT LAND
  645.     NOT
  646.     IF "NOT SINGLE, POSITIVE ARGUEMENT" MERR
  647.     THEN
  648.     ;
  649.  
  650. 'ARG#ERR : "WRONG NUMBER OF ARGUMENTS" MERR ;
  651.  
  652. 'LI : SP OFCASE
  653.     EQZ    C: LISTALL ;C
  654.     1 EQ    C: LFIND MSG ;C
  655.     2 EQ    C: DDUP GT IF OVER + 1- THEN
  656.             1+ SWAP DO I = ": " MSG
  657.                     I LFIND MSG LOOP ;C
  658.     TRUE    C: ARG#ERR ;C
  659.     ENDCASE
  660.     ;
  661.  
  662.  
  663. 'INPUT :
  664.     1POSARG?
  665.         DUP
  666.         LFIND
  667.         MTUP
  668.         SWAP DUP LFIND
  669.         BEGIN
  670.             SWAP DUP
  671.             = ": " MSG
  672.             1+ SWAP
  673.             GETLINE
  674.             LINEBUF C@ 1 GT
  675.         IF
  676.             LENTER
  677.         REPEAT
  678.         UNDER
  679.         MTDN
  680.     ;
  681.  
  682. '(DELETE) :    LFIND
  683.         DUP NEXTLINE
  684.         SWAP
  685.         EOT W@
  686.         OVERWRITE
  687.     ;
  688.  
  689. 'DELETE : 1POSARG?
  690.         (DELETE)
  691.     ;
  692.  
  693. 'REPLACE : 1POSARG?
  694.         DUP
  695.         (DELETE)
  696.         INPUT
  697.     ;
  698.  
  699. 'DELETES : SP 2 EQ
  700.         IF
  701.         DDUP LT IF OVER - 1+ THEN % IF ARG1<ARG2
  702.                     % THEN INTERPRET
  703.                     % AS RANGE !
  704.             0 DO DUP (DELETE) LOOP
  705.             DROP
  706.         ELSE
  707.             ARG#ERR
  708.         THEN
  709.     ;
  710.  
  711. '1READ :    % NO ERROR CHECKING
  712.         % TAKES A LINE FROM THE INPUT FILE AND
  713.         % APPENDS IT TO THE END OF THE
  714.         % TEXT IN THE EDIT BUFFER.
  715.  
  716.     READLINE
  717.     0 EOT W@
  718.     LENTER
  719.     DUP
  720.     EOT W!    % UPDATE EOT
  721.     C!    % EMPLACE NEW EMPTY LINE
  722.     ;
  723.  
  724. 'READ :    % TAKES A SINGLE ARGUMENT FROM STACK AS THE
  725.     % NUMBER OF LINES TO BE READ FROM THE INPUT
  726.     % FILE AND APPEND THEM TO THE END OF THE EDIT
  727.     % BUFFER.
  728.  
  729.     1POSARG?
  730.     BEGIN
  731.         EOT W@ SAFE-END LT
  732.         OVER LAND
  733.     IF
  734.         1READ
  735.         1-    % DECREASE COUNT
  736.     REPEAT
  737.     IF
  738.         "PREMATURE EOF ENCOUNTERED" MSG
  739.     THEN
  740.     ;
  741.  
  742. 'WRITE :    % TAKES A SINGLE ARGUMENT FROM STACK AS
  743.         % THE NUMBER OF LINES TO BE TRANSFERRED
  744.         % FROM THE BEGINNING OF THE EDIT BUFFER
  745.         % TO THE OUTPUT FILE.
  746.     1POSARG?
  747.     1 LFIND    % ADJUSTS POINTERS
  748.     BEGIN    % IF NOT EOT, STILL MORE LINES TO SEND
  749.         DUP C@ 2OVER LAND
  750.     IF
  751.         DUP WRITELINE
  752.         NEXTLINE
  753.         SWAP 1- SWAP
  754.     REPEAT
  755.         % AT THIS POINT HAVE POINTER TO TEXT
  756.         % THAT IS NOT YET SENT AND NUMBER OF LINES
  757.         % YET TO BE SENT AFTER EOT
  758.  
  759.     EDITBUF    % DESTINATION
  760.     EOT W@
  761.     OVERWRITE
  762.     IF IFCR "PREMATURE EOT ENCOUNTERED" MSG THEN
  763.     ;
  764.  
  765.  
  766. 'FINISH :    % USED AT END OF EDIT SESSION TO TRANSFER
  767.         % CONTENTS OF EDIT BUFFER AND ANY ADDITIONAL
  768.         % REMAINING TEXT IN THE INPUT FILE TO THE
  769.         % OUTPUT FILE.
  770.  
  771.     EDITBUF
  772.     BEGIN    % EMPTY EDIT BUFFER
  773.         DUP C@
  774.     IF
  775.         DUP
  776.         WRITELINE
  777.         NEXTLINE
  778.     REPEAT
  779.     DROP
  780.     NEWF
  781.     BEGIN    % TRANSFER REMAINDER OF INPUT FILE
  782.         INPUTFILE-STATUS
  783.         W@ -1 GT
  784.     IF
  785.         READLINE
  786.         LINEBUF WRITELINE
  787.     REPEAT
  788.     % SUMARIZE:
  789.     IFCR
  790.     "SUMARIZING: " MSG
  791.     INPUTFILE-STATUS W@ MINUS =
  792.     " LINES READ AND " MSG
  793.     OUTFILE-STATUS W@ MINUS =
  794.     " LINES WRITTEN." MSG
  795.     % CLOSING STATUS OF OUTPUT FILE:
  796.     +1 OUTFILE-STATUS W!
  797.     ;
  798.  
  799.  
  800. % TEST INPUT:
  801. 1 INPUT
  802. THIS IS THE FIRST LINE
  803. THIS IS THE SECOND LINE
  804. THIS IS THE THIRD LINE
  805. THIS IS THE FOURTH LINE
  806. THIS IS THE LAST LINE
  807.  
  808.  
  809.  
  810.  
  811. ;F
  812.  
  813.  
  814.